perm filename GOBBLE.SAI[OLD,HE] blob
sn#501000 filedate 1980-03-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00018 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
C00004 00003 ! CHANNEL STUFF: readfile
C00005 00004 ! Definitions
C00006 00005 ! rwdo, rwmake, dirmake, codemake, dtypmake, inpinit
C00014 00006 ! nextline, inscan, skipblanks, scan_token
C00018 00007 ! read and fread
C00020 00008 ! get_dtype, verify_dtype, verify_1, verify_2, verify_3, dtype_check
C00031 00009 ! asgbki, identlookup, ensym, vblmake, vtry
C00036 00010 ! grovel (lllop, gllop, stgrovel, lgrovel, constelim)
C00039 00011 ! grovel: REGROVEL: DIR, EOP, DTYP
C00042 00012 ! grovel: DTYP: ARRAY, PROCEDURE
C00048 00013 ! grovel: main body: PROG,BLOCK,COBLOCK,FORR,WHIL,IFF,PAUSE,ABORT,COMMNT
C00052 00014 ! grovel: main body: CASE, RETURN
C00056 00015 ! grovel: main body: DEPROACH, PAS, PVL, NOTE, NOTE1, NOTE2
C00058 00016 ! grovel: main body: AFFIX, UNFIX
C00060 00017 ! grovel: main body: V3ECT, TRANS, ASSIGNMENT, EVDO, PRNT, CMABLE
C00064 00018 ! grovel: main body: MOVE$, OPERATE, CENTER, STOP, motion clauses
C00080 ENDMK
C⊗;
IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
ENTRY;
BEGIN "GOBBLE"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING="FALSE"; ENDC
IFCR ¬ CREFFING THENC
REQUIRE "ALREQ.HDR[AL,HE]" SOURCE_FILE;
ENDC
REDEFINE $$PRGID "[]" = ["GOBBLE"];
ENDC
RCLASS RESWD(STRING NAME; INTEGER TYPE, CODE; RPTR(RESWD) NEXT);
RCLASS IDENT(STRING ID; RPTR(IDENT) NEXT);
INTERNAL RCLASS DEFID(STRING NAME; RANY VAL; RPTR(DEFID) NEXT);
RPTR(RESWD) ARRAY BUCKET[1:26];
INTERNAL RPTR(DEFID) SYSIDS;
RPTR(DEFID) IDS;
RPTR(IDENT) IDENTS;
DEFINE DSKIN_OP = 1;
! CHANNEL STUFF: readfile;
DEFINE MAXFILES="15"; ! This is all an old relic, but why bother changing it;
STRING ARRAY FID[0:MAXFILES];
INTEGER ARRAY EOF[0:MAXFILES];
INTEGER ARRAY BRCHAR[0:MAXFILES];
INTEGER PROCEDURE READFILE(STRING FILEID;INTEGER DMODE(0));
BEGIN
INTEGER CH;
CH←GETCHAN;
FID[CH]←FILEID;
OPEN(CH,"DSK",DMODE,3,0,512,BRCHAR[CH],EOF[CH]);
LOOKUP(CH,FILEID,EOF[CH]);
IF EOF[CH] THEN
BEGIN
USERERR(1,1,"LOOKUP FAILED FOR |"&FILEID&"|");
RELEASE(CH);
CH←-1;
END;
RETURN(CH);
END;
! Definitions;
DEFINE MAXINPLEV=3;
INTEGER ARRAY SCNCHN[1:MAXINPLEV];
STRING ARRAY SCNSTK[0:MAXINPLEV];
INTEGER INPLEV;
RANY SYM;
INTEGER LINBRK,BLNKBRK,IDBRK,STRBRK;
DEFINE UNKN_CODE = 0; ! Unknown code;
DEFINE IDENT_CODE = 1; ! identifier;
DEFINE RW_CODE = 2; ! Reserved word;
DEFINE VAL_CODE = 3; ! Scalar value;
DEFINE STR_CODE = 4; ! String constant;
DEFINE DIR_CODE = 5; ! Directive (DSKIN);
DEFINE EOP_CODE = 6; ! Expression operation (SADD ...);
DEFINE DTYP_CODE = 7; ! Declaration (SVAR ...);
DEFINE PREDEC_CODE = 8; ! Predeclared variable/constant (BARM, XHAT...);
! rwdo, rwmake, dirmake, codemake, dtypmake, inpinit;
PROCEDURE RWDO(STRING ID;INTEGER TYPE,I);
BEGIN
INTEGER B;
RPTR(RESWD) V;
V ← NEW_RECORD(RESWD);
RESWD:NAME[V] ← ID;
RESWD:TYPE[V] ← TYPE;
RESWD:CODE[V] ← I;
B ← ID - '100; ! Use first character as index for proper bucket;
RESWD:NEXT[V] ← BUCKET[B];
BUCKET[B] ← V
END;
PROCEDURE RWMAKE(STRING ID;INTEGER I);
RWDO(ID,RW_CODE,I);
PROCEDURE DIRMAKE(STRING ID;INTEGER I);
RWDO(ID,DIR_CODE,I);
PROCEDURE CODEMAKE(STRING ID;INTEGER I);
RWDO(ID,EOP_CODE,I);
PROCEDURE DTYPMAKE(STRING ID;INTEGER I);
RWDO(ID,DTYP_CODE,I);
PROCEDURE INPINIT;
BEGIN
SETBREAK(LINBRK←GETBREAK,LF,CR,"INS"); ! line break;
SETBREAK(BLNKBRK←GETBREAK," "&'14&TAB&CR&LF,NULL,"XRN");
SETBREAK(IDBRK←GETBREAK,"ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$",NULL,"KXRN");
SETBREAK(STRBRK←GETBREAK,""""&LF,CR,"INS");
INPLEV←0;
DIRMAKE("DSKIN",DSKIN_OP);
RWMAKE("NULL",0);
RWMAKE("AFFIX",AFFIXTYPE);
RWMAKE("COMMENT",COMMNTTYPE);
RWMAKE("ON",CMONTYPE);
RWMAKE("EV",EVDOTYPE);
RWMAKE("CMABLE",CMABLETYPE);
RWMAKE("UNFIX",UNFIXTYPE);
RWMAKE("PR",PROGTYPE);
RWMAKE("BL",BLOCKTYPE);
RWMAKE("CO",COBLOCKTYPE);
RWMAKE("FO",FORRTYPE);
RWMAKE("WH",WHILTYPE);
RWMAKE("UNTL",UNTLTYPE);
RWMAKE("CASE",KASETYPE);
RWMAKE("IF",IFFTYPE);
RWMAKE("PAUSE",PAUSETYPE);
RWMAKE("PROMPT",PROMPTTYPE);
RWMAKE("ABORT",ABORTTYPE);
RWMAKE("RET",RETRNTYPE);
RWMAKE("AS",ASSIGNMENTTYPE);
RWMAKE("PAS",PASTYPE);
RWMAKE("DEPROACH",DEPROACHTYPE);
RWMAKE("MO",MOVE$TYPE);
RWMAKE("TO",TOTYPE);
RWMAKE("OPERATE",OPERATETYPE);
RWMAKE("CENTER",CENTERTYPE);
RWMAKE("ERROR",ERRORTYPE);
RWMAKE("RETRY",RETRYTYPE);
RWMAKE("STOP",STOPTYPE);
RWMAKE("DURATION",DURATIONTYPE);
RWMAKE("FORCE",FORCETYPE);
RWMAKE("STIFFNESS",STIFFTYPE);
RWMAKE("GATHER",GATHERTYPE);
RWMAKE("FORCE_FRAME",F_FRAMETYPE);
RWMAKE("SETBASE",SETBASETYPE); ! This and WRIST are temp hacks for JKS;
RWMAKE("WRIST",WRISTTYPE); ! so he can debug the force wrist;
RWMAKE("PRINT",PRNTTYPE);
RWMAKE("VIA",VIATYPE);
RWMAKE("VELOCITY",VELOCITYTYPE);
RWMAKE("ARRIVAL",APPROACHTYPE);
RWMAKE("DEPARTURE",DEPARTURETYPE);
RWMAKE("OPENING",OPENINGTYPE);
RWMAKE("WOBBLE",WOBBLETYPE);
RWMAKE("SPEED_FACTOR",S_FACTYPE);
RWMAKE("NNULL",NNULLTYPE);
RWMAKE("RTMOVE",RTMOVETYPE);
RWMAKE("SW_TIME",SW_TIMETYPE); ! for vise;
RWMAKE("CW",CWTYPE); ! for driver;
RWMAKE("PVL",PVLTYPE);
RWMAKE("NOTE",NOTETYPE);
RWMAKE("NOTE1",NOTE1TYPE);
RWMAKE("NOTE2",NOTE2TYPE);
RWMAKE("DEBUG",DEBUGTYPE); ! for debugging GROVEL;
CODEMAKE("NOOP",NO_OP);
CODEMAKE("CALL",CALL_OP);
CODEMAKE("AREF",AREF_OP);
CODEMAKE("SSBRTN",SSBRTN_OP);
CODEMAKE("SCALRD",SCALRD_OP);
CODEMAKE("SABS",SABS_OP);
CODEMAKE("SADD",SADD_OP);
CODEMAKE("SSUB",SSUB_OP);
CODEMAKE("SMUL",SMUL_OP);
CODEMAKE("SNEG",SNEG_OP);
CODEMAKE("SDIV",SDIV_OP);
CODEMAKE("STOS",SEXP_OP);
CODEMAKE("MAX",MAX_OP);
CODEMAKE("MIN",MIN_OP);
CODEMAKE("INT",INT_OP);
CODEMAKE("DIV",DIV_OP);
CODEMAKE("MOD",MOD_OP);
CODEMAKE("QUERY",QUERY_OP);
CODEMAKE("SLT",SLT_OP);
CODEMAKE("SEQ",SEQ_OP);
CODEMAKE("SLE",SLE_OP);
CODEMAKE("SGE",SGE_OP);
CODEMAKE("SNE",SNE_OP);
CODEMAKE("SGT",SGT_OP);
CODEMAKE("AND",AND_OP);
CODEMAKE("OR",OR_OP);
CODEMAKE("NOT",NOT_OP);
CODEMAKE("XOR",XOR_OP);
CODEMAKE("EQV",EQV_OP);
CODEMAKE("VMAGN",VMAGN_OP);
CODEMAKE("VDOT",VDOT_OP);
CODEMAKE("VMAKE",VMAKE_OP);
CODEMAKE("SVMUL",SVMUL_OP);
CODEMAKE("VSDIV",VSDIV_OP);
CODEMAKE("VADD",VADD_OP);
CODEMAKE("VSUB",VSUB_OP);
CODEMAKE("VCROSS",VCROSS_OP);
CODEMAKE("RVMUL",RVMUL_OP);
CODEMAKE("TVMUL",TVMUL_OP);
CODEMAKE("AXIS",AXIS_OP);
CODEMAKE("RMAGN",RMAGN_OP);
CODEMAKE("UVECT",UVECT_OP);
CODEMAKE("POS",POS_OP);
CODEMAKE("ORIENT",ORIENT_OP);
CODEMAKE("RRMUL",RRMUL_OP);
CODEMAKE("AXW_ROTN",AXW_ROTN_OP);
CODEMAKE("TMAKE",TMAKE_OP);
CODEMAKE("CONSTR",CONSTR_OP);
CODEMAKE("FTOF",FTOF_OP);
CODEMAKE("TVADD",TVADD_OP);
CODEMAKE("TVSUB",TVSUB_OP);
CODEMAKE("TTMUL",TTMUL_OP);
CODEMAKE("TINVRT",TINVRT_OP);
CODEMAKE("DEPR",DEPR_OP);
CODEMAKE("FMAKE",FMAKE_OP);
DTYPMAKE("REF",REF_DTYPE);
DTYPMAKE("VAL",VAL_DTYPE);
DTYPMAKE("SVAR",SVAL_DTYPE);
DTYPMAKE("VVAR",V3ECT_DTYPE);
DTYPMAKE("TVAR",TRANS_DTYPE);
DTYPMAKE("RVAR",ROTN_DTYPE);
DTYPMAKE("FVAR",FRAME_DTYPE);
DTYPMAKE("EVAR",EVENT_DTYPE);
DTYPMAKE("ARAY",ARAY_DTYPE);
DTYPMAKE("PROC",PROC_DTYPE);
DTYPMAKE("LAB",STMLAB_DTYPE);
DTYPMAKE("OMNLAB",OMNLAB_DTYPE);
DTYPMAKE("STMLAB",STMLAB_DTYPE);
END;
REQUIRE INPINIT INITIALIZATION [2];
! nextline, inscan, skipblanks, scan_token;
PROCEDURE NEXTLINE;
BEGIN
WHILE INPLEV>0 DO
BEGIN
IF ¬EOF[SCNCHN[INPLEV]] THEN
BEGIN
SCNSTK[INPLEV]←SCNSTK[INPLEV] & INPUT(SCNCHN[INPLEV],LINBRK);
RETURN;
END
ELSE
BEGIN
RELEASE(SCNCHN[INPLEV]);
INPLEV←INPLEV-1;
END;
END;
OUTSTR("*");
SCNSTK[0]←SCNSTK[0]&INCHWL&LF;
END;
STRING PROCEDURE INSCAN(INTEGER BRKTBL;REFERENCE INTEGER BC);
BEGIN
WHILE ¬LENGTH(SCNSTK[INPLEV]) DO NEXTLINE;
RETURN(SCAN(SCNSTK[INPLEV],BRKTBL,BC));
END;
INTEGER PROCEDURE SKIPBLANKS;
BEGIN
! returns the first non-"blank" character;
INTEGER C;
STRING S;
DO S←INSCAN(BLNKBRK,C) UNTIL C≠0;
RETURN(C);
END;
INTEGER PROCEDURE SCAN_TOKEN;
BEGIN
RANY R;
STRING SCNID;
INTEGER C,IX;
C ← SKIPBLANKS;
IF C = "$" THEN ! A reserved word;
BEGIN
SCNID ← INSCAN(IDBRK,C);
C ← LOP(SCNID); ! Ignore the $;
C ← SCNID - '100; ! Which bucket to check;
R ← BUCKET[C];
WHILE R ≠ RNULL ∧ ¬EQU(SCNID,RESWD:NAME[R]) DO R ← RESWD:NEXT[R];
IF R = RNULL THEN USERERR(1,1,"GOBBLE: UNKNOWN RESERVED WORD!");
SYM ← R;
RETURN(-1)
END;
IF "A" ≤(C LAND '137)≤ "Z" ∨ C="_" THEN ! an identifier;
BEGIN
INTEGER TYP;
SCNID←INSCAN(IDBRK,C);
R ← SYSIDS;
WHILE R ≠ RNULL ∧ ¬EQU(SCNID,DEFID:NAME[R]) DO R ← DEFID:NEXT[R];
IF R ≠ RNULL THEN
BEGIN
SYM ← DEFID:VAL[R]; ! Found it, return value;
RETURN(-1)
END;
R ← IDENTS;
WHILE R ≠ RNULL ∧ ¬EQU(SCNID,IDENT:ID[R]) DO R ← IDENT:NEXT[R];
IF R = RNULL THEN
BEGIN ! New - have to declare it now;
R ← NEW_RECORD(IDENT);
IDENT:ID[R] ← SCNID;
IDENT:NEXT[R] ← IDENTS;
IDENTS ← R
END;
SYM ← R;
RETURN(-1)
END;
IX ← IF C="-" ∨ C="+" THEN 2 ELSE 1;
IF SCNSTK[INPLEV][IX FOR 1]="." THEN IX ← IX+1;
IF "0"≤SCNSTK[INPLEV][IX FOR 1]≤"9" THEN
BEGIN
SYM ← NEW_RECORD(SVAL);
SVAL:VAL[SYM] ← REALSCAN(SCNSTK[INPLEV],C);
RETURN(-1)
END;
IF C="""" THEN
BEGIN
SCNID ← NULL;
WHILE TRUE DO
BEGIN
C ← LOP(SCNSTK[INPLEV]);
SCNID ← SCNID & INSCAN(STRBRK,C);
IF C="""" THEN
IF SCNSTK[INPLEV]="""" THEN SCNID←SCNID&LOP(SCNSTK[INPLEV])
ELSE DONE
ELSE IF C=LF ∨ C=0 THEN SCNID ← SCNID & CRLF
END;
IF SCNID = NULL THEN SCNID ← CRLF;
SYM ← NEW_RECORD(STCONST);
STCONST:VAL[SYM] ← SCNID;
RETURN(-1)
END;
C ← LOP(SCNSTK[INPLEV]);
RETURN(C)
END;
! read and fread;
INTERNAL RANY RECURSIVE PROCEDURE READ(INTEGER T(0));
BEGIN
RCELL LD;
RCELL C;
RANY V;
IF T=0 THEN T←SCAN_TOKEN;
IF T < 0 THEN RETURN(SYM);
IF T="(" THEN
BEGIN
LD ← C ← RNULL;
WHILE (T←SCAN_TOKEN) ≠ ")" DO
BEGIN
V ← CONS(READ(T),RNULL);
IF LD = RNULL THEN LD ← V ELSE CELL:CDR[C] ← V;
C ← V
END;
RETURN(LD)
END;
V ← NEW_RECORD(CHAR_REC);
CHAR_REC:CHAR[V] ← T;
RETURN(V)
END;
INTERNAL RANY PROCEDURE FREAD(STRING FILE_NAME);
BEGIN ! hack for linking with the parser and/or snail in rpg mode;
SCNSTK[0] ← "($DSKIN """&FILE_NAME&""") ";
RETURN(READ)
END;
! get_dtype, verify_dtype, verify_1, verify_2, verify_3, dtype_check;
FORWARD RPTR(VARIABLE) PROCEDURE VTRY
(RANY V;INTEGER DTYP (INVALID_DTYPE));
! On the next page;
INTEGER PROCEDURE GET_DTYPE(RANY X; INTEGER DTYP (INVALID_DTYPE));
BEGIN
! If X is a variable, VTRY is called on it with DTYP.
This helps in properly declaring undeclared variables
which are first used in expressions;
INTEGER I;
I ← RECTYPE(X);
RETURN ( IF I = LOC(EXPRN) THEN EXPRN:DATATYPE[X]
ELSE IF I = LOC(LBLVAR) THEN LBLVAR:DATATYPE[X]
ELSE IF I = LOC(VARIABLE) THEN VARIABLE:DATATYPE[VTRY(X,DTYP)]
ELSE IF I = LOC(ARRAYDEF) THEN ARRAYDEF:DATATYPE[X]
ELSE IF I = LOC(SVAL) THEN SVAL_DTYPE
ELSE IF I = LOC(V3ECT) THEN V3ECT_DTYPE
ELSE IF I = LOC(ROTN) THEN ROTN_DTYPE
ELSE IF I = LOC(TRANS) THEN TRANS_DTYPE
ELSE IF I = LOC(FRAME) THEN FRAME_DTYPE
ELSE INVALID_DTYPE)
END;
PROCEDURE VERIFY_DTYPE(RPTR(EXPRN,VARIABLE,VALU$) X;INTEGER T);
BEGIN
INTEGER TT;
TT ← GET_DTYPE(X,T);
IF TT≠T THEN
BEGIN
IF ¬(TT = FRAME_DTYPE ∧ T = TRANS_DTYPE) THEN
BEGIN
ALPRIN(X);
USERERR(1,1,"PARSER: wrong expression data type");
END
END
END;
PROCEDURE VERIFY_1(RCELL C;INTEGER T);
IF C=NULL THEN USERERR(1,1,"NOT ENOUGH ARGS")
ELSE VERIFY_DTYPE(CELL:CAR[C],T);
PROCEDURE VERIFY_2(RCELL C;INTEGER T1,T2);
IF CL_LEN(C) < 2 THEN USERERR(1,1,"NOT ENOUGH ARGS")
ELSE
BEGIN
VERIFY_DTYPE(CELL:CAR[C],T1);
VERIFY_DTYPE(CELL:CAR[CELL:CDR[C]],T2)
END;
PROCEDURE VERIFY_3(RCELL C;INTEGER T1,T2,T3);
IF C=NULL THEN USERERR(1,1,"NOT ENOUGH ARGS")
ELSE
BEGIN
VERIFY_DTYPE(CELL:CAR[C],T1);
VERIFY_2(CELL:CDR[C],T2,T3)
END;
PROCEDURE DTYPE_CHECK(RPTR(EXPRN) E);
BEGIN
INTEGER OP,NARGS;
RCELL EARGS,C,T;
RANY P;
OP ← EXPRN:OP[E];
EARGS ← EXPRN:ARGS[E];
EXPRN:DATATYPE[E] ←
IF OP = AREF_OP THEN ARRAYDEF:DATATYPE[P←LLOP(EARGS)]
ELSE IF OP = CALL_OP THEN PROCDEF:DATATYPE[P←LLOP(EARGS)]
ELSE IF MIN_SVAL_OP ≤ OP ≤ MAX_SVAL_OP THEN SVAL_DTYPE
ELSE IF MIN_V3ECT_OP ≤ OP ≤ MAX_V3ECT_OP THEN V3ECT_DTYPE
ELSE IF MIN_ROTN_OP ≤ OP ≤ MAX_ROTN_OP THEN ROTN_DTYPE
ELSE IF MIN_TRANS_OP ≤ OP ≤ MAX_TRANS_OP THEN TRANS_DTYPE
ELSE IF MIN_FRAME_OP ≤ OP ≤ MAX_FRAME_OP THEN FRAME_DTYPE
ELSE INVALID_DTYPE;
CASE OP OF BEGIN
[SCALRD_OP] [QUERY_OP] ; ! don't have any args;
[SABS_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[SADD_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SSUB_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SNEG_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[SMUL_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SDIV_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SEXP_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[MAX_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[MIN_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[INT_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[DIV_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[MOD_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SLT_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SGT_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SEQ_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SLE_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SGE_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SNE_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[AND_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[OR_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[NOT_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[XOR_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[EQV_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[VMAGN_OP] VERIFY_1(EARGS,V3ECT_DTYPE);
[VDOT_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[SVMUL_OP] VERIFY_2(EARGS,SVAL_DTYPE,V3ECT_DTYPE);
[VSDIV_OP] VERIFY_2(EARGS,V3ECT_DTYPE,SVAL_DTYPE);
[VMAKE_OP] VERIFY_3(EARGS,SVAL_DTYPE,SVAL_DTYPE,SVAL_DTYPE);
[VADD_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[VSUB_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[VCROSS_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[TVMUL_OP] VERIFY_2(EARGS,TRANS_DTYPE,V3ECT_DTYPE);
[TVADD_OP] VERIFY_2(EARGS,TRANS_DTYPE,V3ECT_DTYPE);
[TVSUB_OP] VERIFY_2(EARGS,TRANS_DTYPE,V3ECT_DTYPE);
[RVMUL_OP] VERIFY_2(EARGS,ROTN_DTYPE,V3ECT_DTYPE);
[RMAGN_OP] VERIFY_1(EARGS,ROTN_DTYPE);
[AXIS_OP] VERIFY_1(EARGS,ROTN_DTYPE);
[POS_OP] VERIFY_1(EARGS,TRANS_DTYPE);
[ORIENT_OP] VERIFY_1(EARGS,TRANS_DTYPE);
[RRMUL_OP] VERIFY_2(EARGS,ROTN_DTYPE,ROTN_DTYPE);
[UVECT_OP] VERIFY_1(EARGS,V3ECT_DTYPE);
[AXW_ROTN_OP] VERIFY_2(EARGS,V3ECT_DTYPE,SVAL_DTYPE);
[FTOF_OP] VERIFY_2(EARGS,FRAME_DTYPE,FRAME_DTYPE);
[TMAKE_OP] VERIFY_2(EARGS,ROTN_DTYPE,V3ECT_DTYPE);
[CONSTR_OP] VERIFY_3(EARGS,V3ECT_DTYPE,V3ECT_DTYPE,V3ECT_DTYPE);
[TTMUL_OP] VERIFY_2(EARGS,TRANS_DTYPE,TRANS_DTYPE);
[TINVRT_OP] VERIFY_1(EARGS,TRANS_DTYPE);
[DEPR_OP] VERIFY_1(EARGS,FRAME_DTYPE);
[FMAKE_OP] VERIFY_2(EARGS,ROTN_DTYPE,V3ECT_DTYPE);
[SSBRTN_OP] CASE (OP ← SVAL:VAL[CELL:CAR[EARGS]]) OF
BEGIN
[SQRT_OP] [SIN_OP] [COS_OP] [TAN_OP]
[ASIN_OP] [ACOS_OP]
[LOG_OP] [EXP_OP]
[TIME_OP] VERIFY_1(CELL:CDR[EARGS],SVAL_DTYPE);
[ATAN2_OP] VERIFY_2(CELL:CDR[EARGS],SVAL_DTYPE,SVAL_DTYPE)
END;
[CALL_OP] BEGIN "procedure call"
NARGS ← 0;
T ← PROCDEF:ARGS[P];
WHILE EARGS ≠ RNULL DO
BEGIN "count args"
NARGS ← NARGS + 1;
VERIFY_DTYPE((C←LLOP(EARGS)),VARIABLE:DATATYPE[LLOP(T)])
END;
IF NARGS < PROCDEF:NUMARGS[P] THEN
BEGIN "not enough args"
USERERR(1,1,"PARSER: NOT ENOUGH ARGMENTS FOR PROCEDURE");
IF C = RNULL THEN C ← CELL:CDR[EXPRN:ARGS[E]];
WHILE NARGS < PROCDEF:NUMARGS[P] DO
BEGIN
NARGS ← NARGS + 1;
CASE VARIABLE:DATATYPE[LLOP(T)] OF
BEGIN
[SVAL_DTYPE] C ← CELL:CDR[C] ← CONS(FALSEV,RNULL);
[V3ECT_DTYPE] C ← CELL:CDR[C] ← CONS(NILVECT,RNULL);
[ROTN_DTYPE] C ← CELL:CDR[C] ← CONS(NILROTN,RNULL);
[TRANS_DTYPE] C ← CELL:CDR[C] ← CONS(NILTRANS,RNULL);
[FRAME_DTYPE] C ← CELL:CDR[C] ← CONS(NILDEPROACH,RNULL);
ELSE C ← CELL:CDR[C] ← CONS(FALSEV,RNULL)
END
END
END "not enough args"
END "procedure call";
[AREF_OP] BEGIN "array reference"
NARGS ← 0;
WHILE EARGS ≠ RNULL DO
BEGIN "count args"
NARGS ← NARGS + 1;
VERIFY_DTYPE((C←LLOP(EARGS)),SVAL_DTYPE)
END;
IF NARGS < ARRAYDEF:NUMDIMS[P] THEN
BEGIN "not enough subscripts"
USERERR(1,1,"PARSER: NOT ENOUGH SUBSCRIPTS");
IF C = RNULL THEN C ← CELL:CDR[EXPRN:ARGS[E]];
WHILE NARGS < ARRAYDEF:NUMDIMS[P] DO
BEGIN
NARGS ← NARGS + 1;
C ← CELL:CDR[C]
← CONS(NEW_SVAL(ARRAYDEF:BDVALS[P][NARGS,0]),RNULL)
END
END "not enough subscripts"
END "array reference";
[LAST_OP] END;
END;
! asgbki, identlookup, ensym, vblmake, vtry;
RPTR(BLOCK) GVLBLK; ! Current block being gobbled;
RPTR(CMON) CCMON; ! Current cmon being gobbled (if any);
INTEGER TEMP; INITIALIZE(TEMP←0);
INTEGER BLKNO; INITIALIZE(BLKNO←0);
PROCEDURE ASGBKI(RPTR(BLOCK) B);
BEGIN
BLKNO ← BLKNO + 1;
BLOCK:BLID[B] ← "$B" & CVS(BLKNO)
END;
RANY PROCEDURE IDENTLOOKUP(RPTR(IDENT) V);
BEGIN
RPTR(DEFID) D;
IF RECTYPE(V) ≠ LOC(IDENT) THEN
BEGIN
USERERR(1,1,"DRYROT IN IDENTLOOKUP");
RETURN(RNULL)
END;
D ← IDS;
WHILE D ≠ RNULL ∧ ¬EQU(IDENT:ID[V],DEFID:NAME[D]) DO D ← DEFID:NEXT[D];
IF D ≠ RNULL THEN RETURN (DEFID:VAL[D]) ! Success - found it;
ELSE RETURN (V) ! Failure - not defined;
END;
PROCEDURE ENSYM(RPTR(IDENT) ID; RANY V);
BEGIN
RANY D;
IF RECTYPE(ID) ≠ LOC(IDENT) THEN
BEGIN
PRINT(CRLF&"****", IDENT:ID[ID], CRLF);
USERERR(1,1,"NEED AN ID HERE");
RETURN
END;
D ← IDENTLOOKUP(ID);
IF RECTYPE(D) ≠ LOC(IDENT) ∧ VARIABLE:BLK[D] = GVLBLK THEN
USERERR(1,1,"WARNING DUP ID: " & IDENT:ID[ID])
ELSE
BEGIN ! Add a new defid to the list;
D ← NEW_RECORD(DEFID);
DEFID:NAME[D] ← IDENT:ID[ID];
DEFID:VAL[D] ← V;
DEFID:NEXT[D] ← IDS;
IDS ← D
END
END;
RPTR(VARIABLE,LBLVAR) PROCEDURE VBLMAKE(RPTR(IDENT) V; INTEGER DTYP);
BEGIN
RPTR(VARIABLE,LBLVAR) VV;
IF DTYP = STMLAB_DTYPE ∨ DTYP = OMNLAB_DTYPE THEN
VV ← NEW_LBL(IDENT:ID[V],DTYP,GVLBLK)
ELSE
VV ← NEW_VAR(IDENT:ID[V],DTYP,GVLBLK);
ENSYM(V,VV);
RETURN(VV)
END;
RPTR(VARIABLE,LBLVAR) PROCEDURE VTRY(RANY V; INTEGER DTYP (INVALID_DTYPE));
BEGIN "vtry"
! Returns V. If it was a declared variable, it
checks its type to make sure it is DTYP (unless DTYP was not
specified). If it was not declared, VTRY declares it with DTYP.
Complains if V is not a declared variable or an IDENT.;
RVAR VAR;
INTEGER RT,VDT;
RT ← RECTYPE(V);
IF RT = LOC(IDENT) THEN
BEGIN
V ← IDENTLOOKUP(V);
RT ← RECTYPE(V)
END;
IF RT = LOC(IDENT) THEN
BEGIN ! Must be declared;
USERERR(1,1,"VTRY: Will define " & IDENT:ID[V]);
VAR ← VBLMAKE(V,DTYP)
END
ELSE IF RT = LOC(ARRAYDEF) THEN RETURN(V)
ELSE IF RT = LOC(PROCDEF) THEN RETURN(V)
ELSE IF RT = LOC(VARIABLE) THEN VAR ← V
ELSE IF RT = LOC(LBLVAR) THEN RETURN(V)
ELSE BEGIN
USERERR(1,1,"VTRY: Bad argument");
RETURN(V)
END;
VDT ← VARIABLE:DATATYPE[VAR];
IF (DTYP ≠ INVALID_DTYPE) ∧ (VDT ≠ DTYP) THEN
BEGIN ! May want to put right type in;
IF VDT = INVALID_DTYPE THEN VARIABLE:DATATYPE[VAR] ← DTYP
ELSE IF VDT = FRAME_DTYPE ∧ DTYP=TRANS_DTYPE THEN BEGIN ! OK; END
ELSE USERERR(1,1,"VTRY: " & VARIABLE:NAME[V] & " has wrong type")
END;
RETURN(VAR)
END "vtry";
! grovel (lllop, gllop, stgrovel, lgrovel, constelim);
INTERNAL RANY RECPROC GROVEL(RANY SE);
BEGIN
RCELL C;
RANY KIND,V;
INTEGER IX;
OWN INTEGER REFFLG, VALFLG; ! Used for reference & value decs;
LABEL REGROVEL;
RANY PROCEDURE LLLOP;
RETURN(LLOP(C));
RANY PROCEDURE GLLOP;
IF C ≠ RNULL THEN RETURN(GROVEL(LLLOP)) ELSE RETURN(RNULL);
RSTMNT PROCEDURE STGROVEL;
IF C ≠ RNULL THEN
BEGIN
RANY S;
S ← GLLOP;
IF RECTYPE(S)=LOC(EXPRN) ∧ EXPRN:OP[S]=CALL_OP THEN S ← STMAKE(S);
RETURN(CHKREC(S,LOC(STMNT)))
END
ELSE RETURN(STMAKE(RNULL));
RCELL RECPROC LGROVEL(RCELL C);
BEGIN ! Grovels down a list;
RCELL C1,C2,C3;
C1 ← C3 ← RNULL;
WHILE C ≠ RNULL DO
BEGIN
C2 ← GROVEL(LLOP(C));
IF C2 ≠ RNULL THEN
BEGIN
C2 ← CONS(C2,RNULL);
IF C1 = RNULL THEN C1 ← C3 ← C2
ELSE CELL:CDR[C1] ← C2;
C1 ← C2
END
END;
RETURN(C3)
END;
RPTR (VALU$,EXPRN) PROCEDURE CONSTELIM (RPTR(EXPRN) EX);
BEGIN "constelim" ! Takes the expression EX and
replaces it with a simpler one if possible. At the moment, only
checks one level deep, since it is called repeatedly at each level.
It should be simple to make it recursive;
INTEGER TYP, FLAG;
RANY PTR;
IF RECTYPE(EX) ≠ LOC(EXPRN) THEN
BEGIN
PRINT(CRLF&"****"); ALPRIN(EX);
USERERR(1,1,"CONSTELIM: Not an expression");
RETURN(EX);
END;
! Make sure the operands are all constants;
PTR ← EXPRN:ARGS[EX];
FLAG ← FALSE;
WHILE PTR ≠ RNULL DO
BEGIN "cloop"
TYP ← RECTYPE(CELL:CAR[PTR]);
IF FLAG ← (TYP=LOC(SVAL) ∨ TYP=LOC(V3ECT) ∨ TYP=LOC(ROTN) ∨ TYP=LOC(TRANS)
∨ TYP=LOC(FRAME)) THEN PTR ← CELL:CDR[PTR]
ELSE DONE "cloop"
END "cloop";
IF ¬FLAG THEN RETURN(EX) ! Can't do anything;
ELSE RETURN(EVALEXPR(EX,RNULL))
END;
! grovel: REGROVEL: DIR, EOP, DTYP;
REGROVEL:
IF RECTYPE(SE) ≠ LOC(CELL) THEN
IF RECTYPE(SE) = LOC(IDENT) THEN RETURN(VTRY(SE)) ELSE RETURN(SE);
KIND ← CELL:CAR[SE];
C ← CELL:CDR[SE];
IX ← RECTYPE(KIND);
IF IX = LOC(IDENT) THEN
BEGIN
KIND ← IDENTLOOKUP(KIND);
IX ← RECTYPE(KIND);
END;
IF IX = LOC(LBLVAR) THEN
BEGIN
V ← GROVEL(C);
IX ← RECTYPE(V);
IF LBLVAR:SEMANTICS[KIND] ≠ RNULL THEN
BEGIN
PRINT(CRLF&"****"); ALPRIN(KIND);
USERERR(1,1,"DUPLICATE USE OF LABEL")
END
ELSE ASGLBL(KIND,V);
RETURN(V)
END
ELSE IF IX ≠ LOC(RESWD) THEN RETURN(LGROVEL(SE));
IX ← RESWD:TYPE[KIND];
CASE IX OF
BEGIN
[DIR_CODE] BEGIN ! DSKIN_OP is only directive;
V ← GLLOP;
IF RECTYPE(V) = LOC(STCONST) THEN
BEGIN
INTEGER CH;
CH ← READFILE(STCONST:VAL[V]);
IF CH < 0 THEN RETURN(RNULL);
INPLEV ← INPLEV+1;
SCNCHN[INPLEV] ← CH;
SCNSTK[INPLEV] ← INPUT(SCNCHN[INPLEV],LINBRK);
IF EQU(SCNSTK[INPLEV][1 FOR 9],"COMMENT ⊗") THEN
BEGIN ! Skip over E directory page;
DO SCNSTK[INPLEV] ← INPUT(SCNCHN[INPLEV],LINBRK)
UNTIL EQU(SCNSTK[INPLEV][1 FOR 3],"C⊗;")
∨ EOF[SCNCHN[INPLEV]];
IF EOF[SCNCHN[INPLEV]] THEN
USERERR(1,1,"DIRECTORY END NOT DETECTED");
SCNSTK[INPLEV] ← NULL
END;
SE ← READ;
GO TO REGROVEL
END
END;
[EOP_CODE] BEGIN ! Expression;
V ← NEW_RECORD(EXPRN);
EXPRN:OP[V] ← RESWD:CODE[KIND];
EXPRN:ARGS[V] ← LGROVEL(C);
DTYPE_CHECK(V);
IF ¬(EXPRN:OP[V] = SSBRTN_OP ∧
SVAL:VAL[CELL:CAR[EXPRN:ARGS[V]]] = TIME_OP) THEN
V ← CONSTELIM(V);
RETURN(V)
END;
! grovel: DTYP: ARRAY, PROCEDURE;
[DTYP_CODE] BEGIN "VBL"
IF RESWD:CODE[KIND] = REF_DTYPE THEN
BEGIN "refdec"
REFFLG ← TRUE;
GROVEL(C);
REFFLG ← FALSE
END
ELSE IF RESWD:CODE[KIND] = VAL_DTYPE THEN
BEGIN "valdec"
VALFLG ← TRUE;
GROVEL(C);
VALFLG ← FALSE
END
ELSE IF RESWD:CODE[KIND] = ARAY_DTYPE THEN
BEGIN "array dec"
INTEGER DT,NDIMS,I,J;
RPTR(ARRAYDEF) ARAY;
RCELL BNDS;
DT ← RESWD:CODE[LLLOP];
WHILE C ≠ RNULL DO
BEGIN
ARAY ← NEW_RECORD(ARRAYDEF);
ARRAYDEF:DATATYPE[ARAY] ← DT;
ARRAYDEF:BLK[ARAY] ← GVLBLK;
CONSON(ARAY,BLOCK:ARAYS[GVLBLK]);
V ← LLLOP; ! fetch array name;
ARRAYDEF:NAME[ARAY] ← IDENT:ID[V];
ENSYM(V,ARAY);
BNDS ← CELL:CAR[C];
NDIMS ← 0;
WHILE BNDS ≠ RNULL DO
BEGIN
NDIMS ← NDIMS + 1;
BNDS ← CELL:CDR[CELL:CDR[BNDS]]
END;
ARRAYDEF:NUMDIMS[ARAY] ← NDIMS;
IF NDIMS THEN
BEGIN ! this is so procedure arguments can be arrays;
NewArray(REXPR,ARRAYDEF:BOUNDS[ARAY],[1:NDIMS,0:3]);
NewArray(INTEGER,ARRAYDEF:BDVALS[ARAY],[1:NDIMS,0:2]);
END;
BNDS ← LLLOP;
FOR I ← 1 TIL NDIMS DO
FOR J ← 0 TIL 1 DO
BEGIN
ARRAYDEF:BOUNDS[ARAY][I,J] ← GROVEL(LLOP(BNDS));
IF RECTYPE(ARRAYDEF:BOUNDS[ARAY][I,J]) = LOC(EXPRN) THEN
ARRAYDEF:BOUNDS[ARAY][I,J+2] ←
NEW_VAR(NULL,SVAL_DTYPE,BLOCK:PARENT[GVLBLK])
END
END
END "array dec"
ELSE IF RESWD:CODE[KIND] = PROC_DTYPE THEN
BEGIN "procedure dec"
INTEGER NARGS;
RPTR(BLOCK) SAVEBLK,T;
RPTR(DEFID) BLKIDS;
RANY P,N;
RCELL ARGLIST,L;
V ← NEW_RECORD(PROCDEF);
PROCDEF:DATATYPE[V] ← (IF RECTYPE(CELL:CAR[C]) =
LOC(RESWD) THEN RESWD:CODE[LLLOP] ELSE 0);
CONSON(V,BLOCK:PROCS[GVLBLK]);
P ← LLLOP; ! get procedure's name;
PROCDEF:NAME[V] ← IDENT:ID[P];
ENSYM(P,V);
PROCDEF:BLK[V] ← GVLBLK;
BLKIDS ← IDS;
T ← NEW_RECORD(BLOCK);
PROCDEF:BODY[V] ← STMAKE(T);
ASGBKI(T);
BLOCK:PARENT[T] ← SAVEBLK ← GVLBLK;
GVLBLK ← T;
L ← RNULL;
ARGLIST ← CELL:CAR[C]; ! save pointer to arg list;
LGROVEL(LLLOP); ! parse the arg list defining variables;
WHILE ARGLIST ≠ RNULL DO
BEGIN
P ← LLOP(ARGLIST);
WHILE P ≠ RNULL DO
IF RECTYPE((N←LLOP(P))) = LOC(IDENT) THEN
BEGIN
NARGS ← NARGS + 1;
N ← CONS(IDENTLOOKUP(N),RNULL);
IF L = RNULL THEN PROCDEF:ARGS[V] ← N
ELSE CELL:CDR[L] ← N;
L ← N
END
END;
PROCDEF:NUMARGS[V] ← NARGS;
BLOCK:CODE[T] ← LGROVEL(C); ! parse procedure body;
IDS ← BLKIDS; ! Pop variables for this block;
GVLBLK ← SAVEBLK
END "procedure dec"
ELSE WHILE C ≠ RNULL DO
BEGIN
V ← LLLOP;
IF RECTYPE(V) ≠ LOC(IDENT) THEN
BEGIN
PRINT(CRLF&"****"); RECPRN(V); PRINT(CRLF);
USERERR(1,1,"FUNNY THING FOR VARIABLE");
CONTINUE
END;
V ← VBLMAKE(V,RESWD:CODE[KIND]);
IX ← IF REFFLG THEN REFARG ELSE IF VALFLG THEN VALARG ELSE 0;
VARIABLE:ATTRIBUTES[V] ← VARIABLE:ATTRIBUTES[V] LOR IX
END;
RETURN(RNULL)
END;
! grovel: main body: PROG,BLOCK,COBLOCK,FORR,WHIL,IFF,PAUSE,ABORT,COMMNT;
[RW_CODE] BEGIN "RWCODE"
CASE RESWD:CODE[KIND] OF
BEGIN
[PROGTYPE] BEGIN
V←NEW_RECORD(PROG);
PROG:CODE[V]←STGROVEL;
RETURN(STMAKE(V))
END;
[BLOCKTYPE] BEGIN
RBLK SAVEBLK;
RPTR(DEFID) BLKIDS;
V ← NEW_RECORD(BLOCK);
BLKIDS ← IDS;
ASGBKI(V);
SAVEBLK ← GVLBLK;
BLOCK:PARENT[V] ← SAVEBLK;
GVLBLK ← V;
BLOCK:CODE[V] ← LGROVEL(C);
IDS ← BLKIDS; ! Pop variables for this block;
GVLBLK ← SAVEBLK;
RETURN(STMAKE(V))
END;
[COBLOCKTYPE] BEGIN
V ← NEW_RECORD(COBLOCK);
COBLOCK:CODE[V] ← LGROVEL(C);
RETURN(STMAKE(V))
END;
[FORRTYPE] BEGIN
V ← NEW_RECORD(FORR);
FORR:CONVAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,SVAL_DTYPE) ELSE GLLOP);
FORR:INITIAL[V] ← GLLOP;
FORR:STEP[V] ← GLLOP;
FORR:FINAL[V] ← GLLOP;
FORR:BODY[V] ← STGROVEL;
RETURN(STMAKE(V))
END;
[WHILTYPE] BEGIN
V ← NEW_RECORD(WHIL);
WHIL:COND[V] ← GLLOP;
WHIL:BODY[V] ← STGROVEL;
RETURN(STMAKE(V))
END;
[UNTLTYPE] BEGIN
V ← NEW_RECORD(UNTL);
UNTL:BODY[V] ← STGROVEL;
UNTL:COND[V] ← GLLOP;
RETURN(STMAKE(V))
END;
[IFFTYPE] BEGIN
V ← NEW_RECORD(IFF);
IFF:COND[V] ← GLLOP;
IFF:THN[V] ← STGROVEL;
IFF:ELS[V] ← STGROVEL;
RETURN(STMAKE(V))
END;
[PAUSETYPE] BEGIN
V ← NEW_RECORD(PAUSE);
PAUSE:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END;
[PROMPTTYPE] BEGIN
V ← NEW_RECORD(PROMPT);
PROMPT:VAL[V] ← LGROVEL(C); ! Gets a list of print items;
RETURN(STMAKE(V))
END;
[ABORTTYPE] BEGIN
V ← NEW_RECORD(ABORT);
ABORT:VAL[V] ← LGROVEL(C); ! Gets a list of print items;
RETURN(STMAKE(V))
END;
[COMMNTTYPE] BEGIN ! Coded by RF;
V ← NEW_RECORD(COMMNT);
! COMMNT:HESAYS[V] ← LGROVEL(C);
! You don't really want to keep that junk;
RETURN(STMAKE(V))
END;
! grovel: main body: CASE, RETURN;
[KASETYPE] BEGIN
RANY F;
RCELL T,B;
INTEGER S,I,N,J;
V ← NEW_RECORD(KASE);
S ← I ← N ← 0;
KASE:INDEX[V] ← GLLOP;
IF RECTYPE(CELL:CAR[C]) = LOC(CELL) THEN
BEGIN "regular case statement"
T ← C;
WHILE T ≠ RNULL DO ! count the statements;
BEGIN LLOP(T); N ← N +1 END;
KASE:RANGE[V] ← N;
NewArray(INTEGER,KASE:LABS[V],[0:N,0:1]);
ARRCLR(KASE:LABS[V],N);
FOR I ← 0 TIL N-1 DO
IF (F←LLLOP) = RNULL THEN KASE:LABS[V][I,0] ← N ELSE
BEGIN
KASE:LABS[V][I,0] ← S;
S ← S + 1;
F ← GROVEL(F);
IF RECTYPE(F)=LOC(EXPRN) ∧ EXPRN:OP[F]=CALL_OP THEN
F←STMAKE(F);
F ← CONS(F,RNULL);
IF T = RNULL THEN KASE:STMNTS[V] ← F
ELSE CELL:CDR[T] ← F;
T ← F
END
END "regular case statement"
ELSE
BEGIN "numbered case statement"
T ← C;
WHILE T ≠ RNULL DO ! establish the range of the index;
IF RECTYPE(F←LLOP(T)) = LOC(SVAL) THEN
N ← N MAX (I←SVAL:VAL[F]);
KASE:RANGE[V] ← N ← N + 1;
NewArray(INTEGER,KASE:LABS[V],[0:N,0:1]);
ARRCLR(KASE:LABS[V],N);
B ← C; I ← 0;
WHILE C ≠ RNULL DO
IF (F←LLLOP) = RNULL THEN BEGIN "whoops"
WHILE B≠C DO IF RECTYPE(F←LLOP(B))=LOC(SVAL) THEN
KASE:LABS[V][SVAL:VAL[F],0] ← N END "whoops"
ELSE IF RECTYPE(F) = LOC(SVAL) THEN
IF SVAL:VAL[F] ≥ 0 THEN
KASE:LABS[V][SVAL:VAL[F],0] ← S
ELSE
BEGIN
FOR J ← 0 TIL N DO
IF KASE:LABS[V][J,0] = N THEN
KASE:LABS[V][J,0] ← S;
KASE:RANGE[V] ← - KASE:RANGE[V]
END
ELSE
BEGIN
B ← C; S ← S + 1;
F ← GROVEL(F);
IF RECTYPE(F)=LOC(EXPRN) ∧ EXPRN:OP[F]=CALL_OP THEN
F←STMAKE(F);
F ← CONS(F,RNULL);
IF T = RNULL THEN KASE:STMNTS[V] ← F
ELSE CELL:CDR[T] ← F;
T ← F
END
END "numbered case statement";
KASE:NSTMNTS[V] ← S;
IF KASE:RANGE[V] ≥ 0 THEN KASE:LABS[V][N,0] ← S;
RETURN(STMAKE(V))
END;
[RETRNTYPE] BEGIN
V ← NEW_RECORD(RETRN);
RETRN:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END;
! grovel: main body: DEPROACH, PAS, PVL, NOTE, NOTE1, NOTE2;
[DEPROACHTYPE] BEGIN
V ← NEW_RECORD(DEPROACH);
DEPROACH:VAR[V] ← GLLOP;
DEPROACH:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END;
[PASTYPE] BEGIN
V ← NEW_RECORD(PAS);
PAS:VAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN LLLOP ELSE GLLOP);
PAS:VAL[V] ← GLLOP;
IF RECTYPE(PAS:VAR[V]) = LOC(IDENT) THEN
PAS:VAR[V] ← VTRY(PAS:VAR[V],GET_DTYPE(PAS:VAL[V]));
RETURN(STMAKE(V))
END;
[PVLTYPE] BEGIN
V ← NEW_RECORD(PVL);
PVL:VL[V] ← LGROVEL(C);
RETURN(V)
END;
[NOTETYPE] BEGIN
V ← NEW_RECORD(NOTE);
NOTE:HESAYS[V] ← GLLOP; ! Better be a string constant;
RETURN(V)
END;
[NOTE1TYPE] BEGIN
V ← NEW_RECORD(NOTE1);
NOTE1:HESAYS[V] ← GLLOP; ! Better be a string constant;
RETURN(V)
END;
[NOTE2TYPE] BEGIN
V ← NEW_RECORD(NOTE2);
NOTE2:HESAYS[V] ← GLLOP; ! Better be a string constant;
RETURN(V)
END;
[DEBUGTYPE] BEGIN
PRINT(STCONST:VAL[GLLOP],CRLF); ! Better be a string constant;
RETURN(RNULL)
END;
! grovel: main body: AFFIX, UNFIX;
[AFFIXTYPE] BEGIN
RPTR(VARIABLE) VAR;
V←NEW_RECORD(AFFIX);
AFFIX:FRAME1[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
AFFIX:FRAME2[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
AFFIX:BYVAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,TRANS_DTYPE) ELSE GLLOP);
IF AFFIX:BYVAR[V] = RNULL THEN
BEGIN
AFFIX:BYVAR[V] ← VAR ← NEW_RECORD(VARIABLE);
VARIABLE:NAME[VAR] ← NULL;
VARIABLE:DATATYPE[VAR] ← TRANS_DTYPE;
VARIABLE:BLK[VAR] ← GVLBLK
END;
AFFIX:ATEXP[V] ← GLLOP;
AFFIX:RIGID[V] ← ! Rigid (=TRUE) is default;
C = RNULL ∨ ¬EQU("NONRIGIDLY",IDENT:ID[LLOP(C)]);
RETURN(STMAKE(V))
END;
[UNFIXTYPE] BEGIN
V←NEW_RECORD(UNFIX);
UNFIX:FRAME1[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
UNFIX:FRAME2[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
RETURN(STMAKE(V))
END;
! grovel: main body: V3ECT, TRANS, ASSIGNMENT, EVDO, PRNT, CMABLE;
[V3ECTTYPE] BEGIN
V ← NEW_RECORD(V3ECT);
V3ECT:X[V] ← SVAL:VAL[LLLOP];
V3ECT:Y[V] ← SVAL:VAL[LLLOP];
V3ECT:Z[V] ← SVAL:VAL[LLLOP];
RETURN(V)
END;
[TRANSTYPE] BEGIN
V ← NEW_RECORD(TRANS);
TRANS:R[V] ← GLLOP;
TRANS:P[V] ← GLLOP;
RETURN(V)
END;
[PRNTTYPE] BEGIN "prnt"
V ← NEW_RECORD(PRNT);
PRNT:VAL[V] ← LGROVEL(C); ! Gets a list of print items;
RETURN(STMAKE(V))
END "prnt";
[ASSIGNMENTTYPE] BEGIN "assign"
V ← NEW_RECORD(ASSIGNMENT);
ASSIGNMENT:VAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN LLLOP ELSE GLLOP);
ASSIGNMENT:VAL[V] ← GLLOP;
IF RECTYPE(ASSIGNMENT:VAR[V]) = LOC(IDENT) THEN
ASSIGNMENT:VAR[V] ←
VTRY(ASSIGNMENT:VAR[V],GET_DTYPE(ASSIGNMENT:VAL[V]));
RETURN(STMAKE(V))
END "assign";
[EVDOTYPE] BEGIN
! e.g.: (EV EVAR1 +) will signal the event;
V ← NEW_RECORD(EVDO);
EVDO:VAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,EVENT_DTYPE) ELSE GLLOP);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN EVDO:OP[V] ← 0
ELSE IF IX = "-" THEN EVDO:OP[V] ← 1
ELSE USERERR(1,1,"What kind of EV is " & IX & "?");
RETURN(STMAKE(V))
END;
[CMABLETYPE] BEGIN
! e.g.: (CMABLE + cmon) will enable the cmon;
V ← NEW_RECORD(CMABLE);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN CMABLE:FLAG[V] ← 0
ELSE IF IX = "-" THEN CMABLE:FLAG[V] ← 1
ELSE USERERR(1,1,"What kind of CMABLE is " & IX & "?");
! Get the cmon's label;
IF C ≠ RNULL THEN ! refers to labelled cmon;
CMABLE:WHAT[V] ← VTRY(LLLOP,OMNLAB_DTYPE)
ELSE ! refers to unlabelled cmon;
IF IX="-" THEN USERERR(1,1,"Cmon can't disable itself.")
ELSE
IF CCMON ≠ RNULL THEN CMABLE:WHAT[V] ← CCMON
ELSE USERERR(1,1,"Must specify name of cmon.");
RETURN(STMAKE(V))
END;
! grovel: main body: MOVE$, OPERATE, CENTER, STOP, motion clauses;
[MOVE$TYPE] BEGIN "move$"
RANY P;
V ← NEW_RECORD(MOVE$);
MOVE$:WHAT[V] ← GLLOP;
MOVE$:DEST[V] ← GLLOP;
MOVE$:DEXP[V] ← NEW_RECORD(DEXPR);
! Can expect VIA, DURATION, CMON, DEPROACHES;
MOVE$:CLAUSES[V] ← LGROVEL(C);
P←MOVE$:CLAUSES[V];
WHILE P ≠ RNULL DO ! All this does is turn CMON & S_FAC;
BEGIN ! statements into regular clauses;
IF RECTYPE(CELL:CAR[P])=LOC(STMNT) THEN
CELL:CAR[P]←STMNT:SEMANTICS[CELL:CAR[P]];
IF RECTYPE(CELL:CAR[P])=LOC(DEXPR) THEN
MOVE$:DEST[V] ← DEXPR:EXPN[CELL:CAR[P]];
P←CELL:CDR[P];
END;
RETURN(STMAKE(V))
END "move$";
[OPERATETYPE] BEGIN "operate"
RANY P;
V ← NEW_RECORD(OPERATE);
OPERATE:WHAT[V] ← GLLOP;
OPERATE:DEST[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(CHAR_REC)
THEN LLLOP ELSE GLLOP);
! Can expect DURATION, CMON, TORQUE, VELOCITY,
STOP_WAIT_TIME, ... ;
OPERATE:CLAUSES[V] ← LGROVEL(C);
P←MOVE$:CLAUSES[V];
WHILE P ≠ RNULL DO ! All this does is turn CMON & S_FAC;
BEGIN ! statements into regular clauses;
IF RECTYPE(CELL:CAR[P])=LOC(STMNT) THEN
CELL:CAR[P]←STMNT:SEMANTICS[CELL:CAR[P]];
P←CELL:CDR[P]
END;
RETURN(STMAKE(V))
END "operate";
[CENTERTYPE] BEGIN "center"
RANY P;
V ← NEW_RECORD(CENTER);
CENTER:CF[V] ← GLLOP;
! Can expect CMON someday, ERROR handler now;
CENTER:CLAUSES[V] ← LGROVEL(C);
P←CENTER:CLAUSES[V];
WHILE P ≠ RNULL DO ! All this does is turn CMON & S_FAC;
BEGIN ! statements into regular clauses;
IF RECTYPE(CELL:CAR[P])=LOC(STMNT) THEN
CELL:CAR[P]←STMNT:SEMANTICS[CELL:CAR[P]];
P←CELL:CDR[P]
END;
RETURN(STMAKE(V))
END "center";
[ERRORTYPE] BEGIN "error"
V ← NEW_RECORD(ERROR);
ERROR:BITS[V] ← GLLOP;
ERROR:BODY[V] ← STGROVEL;
RETURN(V)
END "error";
[RETRYTYPE] BEGIN "retry"
V ← NEW_RECORD(RETRY);
RETURN(STMAKE(V))
END "retry";
[STOPTYPE] BEGIN "stop"
V ← NEW_RECORD(STOP);
STOP:CF[V] ← GLLOP;
RETURN(STMAKE(V))
END "stop";
[CMONTYPE] BEGIN
RPTR(CMON) S;
S ← CCMON; ! save outermost cmon;
CCMON ← V ← NEW_RECORD(CMON);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN CMON:FLAGS[V] ← 0 ! Regular cmon;
ELSE IF IX = "-" THEN CMON:FLAGS[V] ← 1 ! Deferred cmon;
ELSE USERERR(1,1,"What kind of CMON is " & IX & "?");
CMON:CONDITION[V] ← GLLOP;
CMON:CONCLUSION[V] ← STGROVEL;
CCMON ← S; ! restore old outermost cmon;
IF RECTYPE(CMON:CONDITION[V]) = LOC(ERROR) THEN
BEGIN ! treat error handler specially;
ERROR:BODY[CMON:CONDITION[V]] ← CMON:CONCLUSION[V];
RETURN(CMON:CONDITION[V]);
END;
CONSON(V,BLOCK:CMONS[GVLBLK]);
RETURN(STMAKE(V))
END;
[VIATYPE] BEGIN "via"
RANY CLS; ! Clause;
V ← NEW_RECORD(VIA);
VIA:PLACE[V] ← GLLOP;
VERIFY_DTYPE(VIA:PLACE[V],TRANS_DTYPE); ! Check type is ok;
VIA:ACTPLACE[V] ← NEW_RECORD(DEXPR);
WHILE C ≠ RNULL DO
BEGIN
IF RECTYPE(CLS←GLLOP) = LOC(VELOCITY) THEN
VIA:VELOC[V] ← CLS
ELSE IF RECTYPE(CLS) = LOC(DURATION) THEN
VIA:TIME[V] ← CLS
ELSE IF RECTYPE(CLS) = LOC(STMNT) THEN
IF RECTYPE(STMNT:SEMANTICS[CLS]) = LOC(EVDO)
∧ EVDO:OP[STMNT:SEMANTICS[CLS]]=0
THEN ! Treat SIGNAL as special;
VIA:CODE[V] ← STMNT:SEMANTICS[CLS]
ELSE
BEGIN
RPTR(CMON) S;
VIA:CODE[V] ← S ← NEW_RECORD(CMON);
CMON:CONDITION[S] ←
NEW_VAR(".E"&CVS(TEMP←TEMP+1),EVENT_DTYPE,GVLBLK);
CMON:CONCLUSION[S] ← CLS;
CONSON(S,BLOCK:CMONS[GVLBLK]);
END
ELSE BEGIN ALPRIN(CLS);PRINT(CRLF);
USERERR(1,1,"Funny thing for VIA clause") END;
END;
RETURN(V)
END "via";
[APPROACHTYPE] BEGIN "approach"
RANY CLS; ! Clause for code;
V ← NEW_RECORD(APPROACH);
APPROACH:THRU[V] ← GLLOP;
APPROACH:ACTPLACE[V] ← NEW_RECORD(DEXPR);
CLS ← GLLOP;
IF CLS ≠ RNULL THEN ! Deal with associated code;
IF RECTYPE(STMNT:SEMANTICS[CLS]) = LOC(EVDO)
∧ EVDO:OP[STMNT:SEMANTICS[CLS]]=0
THEN ! Treat SIGNAL as special;
APPROACH:CODE[V] ← STMNT:SEMANTICS[CLS]
ELSE
BEGIN
RPTR(CMON) S;
APPROACH:CODE[V] ← S ← NEW_RECORD(CMON);
CMON:CONDITION[S] ←
NEW_VAR(".E"&CVS(TEMP←TEMP+1),EVENT_DTYPE,GVLBLK);
CMON:CONCLUSION[S] ← CLS;
CONSON(S,BLOCK:CMONS[GVLBLK]);
END;
RETURN(V)
END "approach";
[DEPARTURETYPE] BEGIN "departure"
RANY CLS; ! Clause for code;
V ← NEW_RECORD(DEPARTURE);
DEPARTURE:THRU[V] ← GLLOP;
DEPARTURE:ACTPLACE[V] ← NEW_RECORD(DEXPR);
CLS ← GLLOP;
IF CLS ≠ RNULL THEN ! Deal with associated code;
IF RECTYPE(STMNT:SEMANTICS[CLS]) = LOC(EVDO)
∧ EVDO:OP[STMNT:SEMANTICS[CLS]]=0
THEN ! Treat SIGNAL as special;
DEPARTURE:CODE[V] ← STMNT:SEMANTICS[CLS]
ELSE
BEGIN
RPTR(CMON) S;
DEPARTURE:CODE[V] ← S ← NEW_RECORD(CMON);
CMON:CONDITION[S] ←
NEW_VAR(".E"&CVS(TEMP←TEMP+1),EVENT_DTYPE,GVLBLK);
CMON:CONCLUSION[S] ← CLS;
CONSON(S,BLOCK:CMONS[GVLBLK]);
END;
RETURN(V)
END "departure";
[WOBBLETYPE] BEGIN "wobble"
V ← NEW_RECORD(WOBBLE);
WOBBLE:VAL[V] ← GLLOP;
RETURN(V)
END "wobble";
[OPENINGTYPE] BEGIN "opening"
V ← NEW_RECORD(OPENING);
OPENING:VAL[V] ← GLLOP;
RETURN(V)
END "opening";
[DURATIONTYPE] BEGIN "duration"
V ← NEW_RECORD(DURATION);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
DURATION:TIME_RELN[V] ←
IF IX = ">" THEN 1
ELSE IF IX = "<" THEN 2
ELSE IF IX = "=" THEN 3
ELSE 0;
DURATION:TIME[V] ← GLLOP;
RETURN(V)
END "duration";
[VELOCITYTYPE] BEGIN "velocity"
V ← NEW_RECORD(VELOCITY);
VELOCITY:VELOC[V] ← GLLOP;
RETURN(V)
END "velocity";
[FORCETYPE] BEGIN "force"
V ← NEW_RECORD(FORCE);
FORCE:DIRECT[V] ← GLLOP;
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
FORCE:REL[V] ← IF IX = "<" THEN SIGLT ELSE SIGGE;
! treat "=" & "≥" the same;
IF RECTYPE(CELL:CAR[C]) = LOC(CHAR_REC) THEN
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN FORCE:REL[V] ← FORCE:REL[V] LOR SIGMAG;
FORCE:VAL[V] ← GLLOP;
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
FORCE:TYPE[V] ← IF IX = "-" THEN FALSE ELSE TRUE;
! force along axis = TRUE, torque about axis = FALSE;
FORCE:F_F[V] ← GLLOP; ! Get force frame spec;
RETURN(V)
END "force";
[STIFFTYPE] BEGIN "stiffness"
V ← NEW_RECORD(STIFF);
! STIFF:STIFFNESS[V] ← LGROVEL(LLLOP); ! Get the 6 stiffness values;
STIFF:K[V] ← GLLOP; ! Get the 3 force values;
STIFF:G[V] ← GLLOP; ! Get the 3 torque values;
STIFF:F_F[V] ← GLLOP; ! Get force frame spec;
RETURN(V)
END "stiffness";
[GATHERTYPE] BEGIN "gather"
V ← NEW_RECORD(GATHER);
IX ← 0;
WHILE C ≠ RNULL DO ! See what forces we're to gather;
BEGIN
STRING S;
S ← IDENT:ID[CELL:CAR[C]];
IX ← IX LOR
(IF EQU(S,"TBL") THEN 1 LSH 12 ELSE
IF S = "F" THEN 1 LSH (S[2 TO 2] - "X") ELSE
IF S = "M" THEN 1 LSH (S[2 TO 2] - "X" + 3) ELSE
IF S = "T" THEN 1 LSH (S[2 TO 2] - "1" + 6) ELSE 0);
LLOP(C)
END;
GATHER:BITS[V] ← IX; ! Store away forces to gather;
RETURN(V)
END "gather";
[F_FRAMETYPE] BEGIN "force frame"
V ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[V] ← GLLOP;
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
F_FRAME:C_SYS[V] ← IF IX = "⊗" THEN FHAND ELSE FTABLE;
RETURN(V)
END "force frame";
[SETBASETYPE] BEGIN "setbase" ! This and WRIST below are temp hacks;
V ← NEW_RECORD(SETBASE);
IF C ≠ NULL_RECORD THEN
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
SETBASE:VAL[V] ← IF IX = "-" THEN FALSE ELSE TRUE;
RETURN(STMAKE(V))
END "setbase";
[WRISTTYPE] BEGIN "wrist"
V ← NEW_RECORD(WRIST);
WRIST:K[V] ← GLLOP;
WRIST:G[V] ← GLLOP;
RETURN(STMAKE(V))
END "wrist";
[S_FACTYPE] BEGIN "speed_factor"
V ← NEW_RECORD(S_FAC);
S_FAC:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END "speed_factor";
[NNULLTYPE] BEGIN "nnull"
V ← NEW_RECORD(NNULL);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
NNULL:FLAG[V] ← IF IX = "+" THEN TRUE ELSE FALSE;
RETURN(V)
END "nnull";
[RTMOVETYPE] BEGIN "rtmove" ! Use runtime traj calc - hack for msm;
V ← NEW_RECORD(RTMOVE);
RETURN(V)
END "rtmove";
[SW_TIMETYPE] BEGIN "stop_wait_time"
V ← NEW_RECORD(SW_TIME);
SW_TIME:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END "stop_wait_time";
[CWTYPE] BEGIN
V ← NEW_RECORD(CW);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
CW:FLAG[V] ← IF IX = "-" THEN TRUE ELSE FALSE;
RETURN(STMAKE(V))
END;
[TOTYPE] BEGIN "to" ! Kludge for alternative MOVE syntax;
V ← NEW_RECORD(DEXPR);
DEXPR:EXPN[V] ← GLLOP; ! Get destination for MOVE;
RETURN(V)
END "to";
ELSE RETURN(RNULL)
END
END;
ELSE END;
RETURN(SE)
END;
END $$PRGID;